
package Sgdb::StatusLine;
use Sgdb::Utils qw( :DEFAULT
                    ) ;

# pragmas for all
use warnings ;
use strict ;
use integer ;
use bytes ;

our $balloon ;
my  @pre_req ;

sub new {
    my $self = shift or die "whoami" ;
    my $topf = shift or die "top frame needed" ;

    my $status = $topf->Label ( pref 'status-bar-label' ) ;

    hook_add ('telthem'              => [\&send_status_message, $status, ''     ],
              'telthemloud'          => [\&send_status_message, $status, 'loud' ],
              'display-in-statusbar' => [\&send_status_message, $status, 'local'],
              'clean-status'         => [\&clean_status_message,$status         ],
              'set-title'            => [\&set_title, $mainwindow               ],
              ) ;

    my $joe = $ENV{USER} || '' ;

    hook_run( 'telthem',                     # well, the next kludge is harmless
              ("Hey! It's the Middle of the Night!", # 0-4
               "Early morning. Ha? ",                # 4-8
               "Good Morning $joe",                  # 8-12
               "Good Noon $joe",                     # 12-16
               "Good Afternoon $joe",                # 16-20
               "Good Evening $joe",                  # 20-24
               "Hi there",                           # earth slows down (y2g bug?)
               ) [(localtime ( time() ) )[2] / 4 ]
              ) ;

    $balloon = $mainwindow -> Balloon( # -statusbar => $status,
                                       pref ('help-mode-balloon'),
                                       ) ;

    $balloon -> Subwidget( 'message' ) -> configure ( -justify => 'left', -foreground => 'blue4') ;
    $balloon -> attach ( @$_ ) for @pre_req ;


    $balloon -> configure( -state => 'balloon' ,
                           -initwait => 1000 )
      if args ('swuch') and
        ($balloon -> configure( '-state' ))[4] eq 'none' ;
    # tmp kludge: swuch is a new feature, help them out

    $status ;
}

sub top_menu_show_balloon_help {

    my $m = shift ;

    my  $balloon_state ;
    tie $balloon_state, 'Tk::Configure', $balloon, '-state' ;

    $m -> add ( 'checkbutton',
                -label => 'Show Balloon Help' ,
                -onvalue => 'balloon',
                -offvalue => 'none',
                -variable => \$balloon_state,
                ) ;
}

my $last_message ;
sub send_status_message {

    my  ($status, $type) = (shift, shift) ;

    if    ( ! $type ) {
    }
    elsif ( $type eq 'loud') {

        $status -> after( 1000, [ $status, 'configure', -background => $status -> cget ( '-background' ) ])
          unless 'red' eq $status -> cget( '-background' ) ;
        $status -> configure( -background => 'red' ) ;
        $status -> bell () ;
    }
    $last_message = join '', @_, '' ;
    $status -> configure ( '-text' , $last_message =~ /^(.*)$/m ) ;
}

sub clean_status_message {
    return unless length $last_message ;
    $_[0] -> configure( -text => $last_message = '' ) ;
}

sub ex_balloonset {

    my $widget = shift ;

    my @opt = @_ or return telme 'no args' ;

    ($widget, @opt ) = ( shift @opt, $widget, @opt ) unless ref $widget ;


    if ( @opt & 1 ) {
      $_ = shift @opt ;
      s/^\n+// ; s/\n+$// ;
      unshift @opt, '-msg', $_ ;
    }

    if ($balloon ) {
      $balloon -> attach ($widget, @opt ) ;
    } else {
      push @pre_req,     [$widget, @opt ] ;
    }
    $widget ;
}

sub set_title {

    my ( $mw, $type, $msg ) = @_ ;

    $msg =~ s/^\s+// ;
    $msg =~ s/\s+$// ;

    my $title = $mw -> title() ;

    my ( $symm, $file, $target, $frame ) =
        $title =~ m/(?:Sgdb)?\s*(\S*)\s*\{\s*(.*?)\s*\@\s*(.*?)\s*\}/ ;
    for ( $symm, $file, $target, $frame ) { $_ ||= '' }

    if    ( $type eq 'file' ) {

        ( $file, $target, $frame ) = ( $msg, ' ', ' ' ) ;
    }
    elsif ( $type eq 'target' ) {

        $target = $msg ;
        $frame  =  ' ' ;
    }
    elsif ( $type eq 'socket' ) {

        $target =~ s/\|.*// ;
        $target .= "|$msg " ;
        $frame    = '  ' ;
    }
    elsif ( $type eq 'frame' ) {

        $frame    = $msg ;
    }
    elsif ( $type eq 'symm' ) {

        $symm = $msg ;
    }
    else {
        telme "bad type: $type" ;
    }

#     my $name = $remotegui ? 'Sgdb-RGUI' : 'Sgdb' ;
    $mw -> title ( "Sgdb $symm \{ $file \@ $target } $frame" ) ;
}

sub top_menu_show_FAQ {

    # add recent to top menu
    my $glob = "/emc/ucode/sdp/sgdb6/share/doc/FAQ/*.pod" ;
    my @pref = ( -tearoff => 0, pref 'top-menu' );
    my $m = shift ;

    foreach my $f ( glob $glob ) {
        my ($name) = $f =~ m{([^/]+)\.pod} ;
        $name =~ y/_/ / ;
        my $sm = $m -> Menu ( @pref ) ;

        $m -> add ( 'cascade' ,
                    -label => $name ,
                    -menu => $sm ) ;

        $sm -> configure ( -postcommand => [\&read_FAQ_file, $sm, $f ] ) ;
    }
}

sub helpthem {

    hook_run 'show-data-messages' ;
    $_ = join "\n", @_ ;
    s/^=over +\d//gm ;
    s/^=item +(\d+) *\n/$1: /gm ;
    s/^=item /* /gm ;
    s/^=\w+/ /gm ;
    s/E\<gt\>/\@\>/gm ;
    s/E\<lt\>/\@\</gm ;
    s/[A-Z]\<(.*?[^\@])\>/$1/gm ;
    s/\@(\>|\<)/$1/gm ;
    s/\n\n+/\n/gm ;
    telthem $_ ;
}

sub read_FAQ_file {

    my $m = shift or return telme 'no menu' ;
    my $f = shift or return telme 'no file' ;

    $m -> delete(0, 'end') ;

    open F, $f or return telthemloud "can't open $f: $!" ;
    my $quest ;
    my $answr ;
    while ( $_ = <F> ) {
        if ( /^=head3\s*(.*)/ ) {
            my $nextq = $1 ;
            $m -> add ( 'command',
                        -label => $quest ,
                        -command => [\&helpthem, $quest, $answr]
                      ) if $quest and $answr ;
            $answr = '' ;
            $quest = $nextq ;
        }
        else {
            $answr .= $_ ;
        }
    }
    close F ;

    $m -> add ( 'command',
                -label => $quest ,
                -command => [\&helpthem, $quest, $answr]
              ) if $quest and $answr ;
}

'end'
